Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/PASCAL/0189.ZIP/LOAN2.INC

Text File | 1986-02-08 | 18KB | 537 lines

  const  ACCEPT    = 'A';    { Action codes. }
         MODIFY    = 'M';
         PRINT     = 'P';

         VIDEO     = 'V';    { Output device codes. }
         PRINTER   = 'P';

         MIN_LOAN  = 100.0;       { Program limits. }
         MAX_LOAN  = 9999999.99;  { These values may be reset to }
         MIN_RATE  = 0.0;         { impose stricter range checking. }
         MAX_RATE  = 99.999;
         MIN_PMT   = 5.00;
         MAX_PMT   = 9999999.99;
         MAX_TERM  = 360;         { Stated as number of payments. }
         END_INP   = 16;          { Last user input field on LOAN.SCR }

  type  Full_Name   = record
                        first_name      : Str_15;
                        last_name       : Str_15;
                        title           : Str_10;
                      end;

        Loan_Record = record
                        collateral    : Str_40;
                        principle     : Real;
                        rate          : Real;
                        payment       : Real;
                        pmts_per_yr   : Integer;
                        first_mo      : Integer;
                        first_yr      : Integer;
                        no_of_pmts    : Real;
                        select_yr     : Integer;
                        out_dev       : Char;
                        unused        : string[9];
                      case commercial : Boolean of
                          TRUE        : ( business_name : Str_40);
                          FALSE       : ( borrower      : Full_Name);
                      end;

  var    loan         : Loan_Record;
         loan_file    : file of Loan_Record;
         file_name    : File_ID;
         inp_scrn     : Scrn;
         fld_dat      : Inp_Parms;
         action       : Char;
         exit_flag,
         modified     : Boolean;

  procedure Initialize;

    begin
      ClrScr; Write('Initializing...');
      FillChar(loan,SizeOf(loan),ZERO);
      output_id := 'Video Screen';
      help_flag := FALSE;
      err_flag := FALSE;
      esc_flag := FALSE;
      quit_flag := FALSE;
      exit_flag := FALSE;
      modified := FALSE;
      end_session := FALSE;
      Load_Input_Scrn('LOAN.SCR',inp_scrn,fld_dat);
      Load_Help_Text('LN-HELP.SCR');
    end; { Intitialize }

  procedure Select_Loan_File;

    procedure Get_FileSpec(var file_name: File_ID);
      const chr_set     : Printable_Char = [':','0'..'9','A'..'Z'];
            ctrl_set    : Control_Char   = [CR,BS,QUIT];
            cmd_fld     : Fld_Parms      =
                           ( xloc        : 56;           { Column }
                             yloc        : MSG_LINE;     { Row }
                             fld_len     : 10;           { Length }
                             fld_type    : UC_TEXT;      { Upper Case }
                             exit_type   : MANUAL;       { <CR> Required }
                             fld_msg     : '');          { None }

      var   inp_ok      : Boolean;

      function Valid_FileID: Boolean;
        var  col_pos : Byte;

        begin
          col_pos := Pos(':',inp_str);
          if (col_pos = ZERO) and (inp_str[1] in ['A'..'Z']) then
            Valid_FileID := TRUE
          else
            if (col_pos = 2) and (inp_str[3] in ['A'..'Z']) then
              if (inp_str[1] in ['A'..'P']) then
                 Valid_FileID := TRUE
              else Valid_FileID := FALSE
            else
              Valid_FileID := FALSE;
        end; { Valid_FileID }

      begin { Get_FileSpec }
        esc_flag := FALSE;
        inp_ok := FALSE;
        ClrScr;
        Repeat
          Display_Prompt(CMD_LINE,'MSG',
               'Up to 8 characters beginning with a letter. | ' +
                QUIT_KEY + 'to Exit');
          Display_Prompt(MSG_LINE,'INP',
               'Enter LOAN FILE NAME to be created or updated ==> ');
          Init_Field(FILL_CHAR,cmd_fld);
          Get_Field_Input(cmd_fld,chr_set,ctrl_set);
          if (not esc_flag) then
            if Valid_FileID then
              begin
                inp_ok := TRUE;
                file_name := inp_str + '.LDT';
              end
            else
              Disp_Error_Msg((inp_str + ' is not a valid file name.'));
        Until (inp_ok or esc_flag);
        GoToXY(1,CMD_LINE); ClrEol;
      end; { Get_FileSpec }

    procedure Open_Loan_File(file_name: File_ID);
      begin
        Assign(loan_file,file_name);
{$I-}
        Reset(loan_file); io_status := IOresult;
        if (io_status = ZERO) then
          Read(loan_file,loan); io_status := IOresult;
{$I+}
        if (io_status <> ZERO) then
          Disp_IO_Error(file_name);
      end; { Open_Loan_File }

    procedure Make_New_File(file_name: File_ID);

      procedure Make_Loan_File;

      procedure Set_Default_Values;
        begin
          FillChar(loan,SizeOf(loan),ZERO);
          with loan do
          begin
            principle    := MIN_LOAN;
            rate         := MIN_RATE;
            no_of_pmts   := 12;
            first_mo     := 1;
            first_yr     := 1980;
            pmts_per_yr  := 12;
            select_yr    := ZERO;
            out_dev      := VIDEO;
            commercial   := FALSE;
          end;
        end; { Set_Default_Values }

        begin
          Assign(loan_file,file_name);
{$I-}
          Rewrite(loan_file); io_status := IOresult;
{$I+}
          if (io_status = ZERO) then
            Set_Default_Values
          else
            Disp_IO_Error(file_name);
        end; { Make_Loan_File }

      begin { Make_New_File }
        Display_Prompt(CMD_LINE,'INP',
                         'Do you want to create a NEW loan file? (Y/N) ==> ');
        if (Valid_Key(['Y','N']) = 'Y') then
          Make_Loan_File
        else
          esc_flag := TRUE;
      end; { Make_New_File }

    begin { Select_Loan_File }
      Get_FileSpec(file_name);
      if (not esc_flag) then
        if Exist(file_name) then
          Open_Loan_File(file_name)
        else
          Make_New_File(file_name);
      ClrScr;
    end; { Select_Loan_File }

  function Current_Value(field: Byte): Str_80;
    var num_str : Str_80;
        len     : Byte;

    begin
      Current_Value := NULL;
      len := fld_dat[field].fld_len;
      with loan, fld_dat[field] do
      case field of
            1       : if commercial then
                        Current_Value :='X'
                      else
                        Current_Value := ' ';
            2       : if commercial then
                        Current_Value := business_name;
            3       : if (not commercial) then
                        Current_Value :='X'
                      else
                        Current_Value := ' ';
            4       : if (not commercial) then
                        Current_Value := borrower.last_name;
            5       : if (not commercial) then
                        Current_Value := borrower.first_name;
            6       : if (not commercial) then
                        Current_Value := borrower.title;
            7       : Current_Value := collateral;
            8       : begin
                        Str(principle:len:2,num_str);
                        Current_Value := num_str;
                      end;
            9       : begin
                        Str(rate:len:3,num_str);
                        Current_Value := num_str;
                      end;
            10      : begin
                        Str(payment:len:2,num_str);
                        Current_Value := num_str;
                      end;
            11      : begin
                        Str(pmts_per_yr:len,num_str);
                        Current_Value := num_str;
                      end;
            12      : begin
                        Str(first_mo:len,num_str);
                        if (first_mo < 10) then
                          num_str[1] := '0';
                        Current_Value := num_str;
                      end;
            13      : begin
                        Str(first_yr:len,num_str);
                        Current_Value := num_str;
                      end;
            14      : begin
                        Str(no_of_pmts:len:2,num_str);
                        Current_Value := num_str;
                      end;
            15      : begin
                        Str(select_yr:len,num_str);
                        Current_Value := num_str;
                      end;
            16      : Current_Value := out_dev;
            17      : Current_Value :=
                        Copy(file_name,1,(Pos('.',file_name) - 1));
            18      : begin
                        if ((no_of_pmts * payment) > 0.0) then
                          begin
                            Str((no_of_pmts * payment):len:2,num_str);
                            Current_Value := num_str;
                          end
                        else
                          Current_Value := '   Invalid';
                      end;
            19      : begin
                        if ((no_of_pmts * payment - principle) > 0.0) and
                           (rate > 0.0) then
                          begin
                            Str((no_of_pmts * payment - principle):len:2,
                                 num_str);
                            Current_Value := num_str;
                          end
                        else
                          Current_Value := '   Invalid';
                      end;
      end; {case}
    end; { Current_Value }

  procedure Disp_Field_Value(field: Byte);
    var fld_str : Str_80;

    begin
      fld_str := Current_Value(field);
      if fld_str <> NULL then
        with fld_dat[field] do
        begin  { Display fld_str and clear to end of field. }
          GoToXY(xloc,yloc); Write(fld_str);
          Repeat_Char(SPACE,(fld_len - Length(fld_str)));
        end
      else
        Init_Field(FILL_CHAR,fld_dat[field]);
    end; { Disp_Field_Value }

  procedure Display_Current_Values;
    var  fld_no  : Byte;

    begin
      ClrScr; Disp_Input_Scrn(inp_scrn);
      for fld_no := 1 to fld_cnt do
        Disp_Field_Value(fld_no);
    end; { Display_Current_Values }

  procedure Select_Action;
    var   cmd_msg     : Str_80;

    begin
      cmd_msg := 'Accept  |  Modify  |  Print  | ' + HELP_KEY +
                 'HELP  | ' + QUIT_KEY + 'Exit';
      Display_Prompt(CMD_LINE,'CMD',cmd_msg);
      Display_Prompt(MSG_LINE,'INP'
                       ,'Press a CMD: key to enter selection ==> ');
      action := Valid_Key(['A','M','P',HELP,QUIT]);
    end; { Select_Action }

  procedure Accept_Data;
    begin
{$I-}
      Reset(loan_file);
      io_status := IOresult;
      if (io_status = ZERO) then
        begin
          Write(loan_file,loan);
          io_status := IOresult;
        end;
{$I+}
      if (io_status = ZERO) then
        modified := FALSE
      else
        Disp_IO_Error(file_name);
    end; { Accept_Data }

procedure Modify_Data(fld_no,last_fld: Byte);
  var periodic_rate      : Real;

  function Payment_Amt: Real;
    var cents,
        pmt_amt,
        int_factor : Real;

    function Rate_Factor: Real;
      var i       : Byte;
          adj,
          accum,
          factor  : Real;

      begin
        accum := 1.0; factor := 1.0 + periodic_rate;
        for i := 1 to Trunc(loan.no_of_pmts) do
          accum := (accum / factor);
        if Frac(loan.no_of_pmts) > 0.0 then
          begin
            adj := accum - (accum / factor);
            adj := adj * Frac(loan.no_of_pmts);
            accum := accum - adj;
          end;
        Rate_Factor := accum;
      end; { Rate_Factor }

    begin { Payment_Amt }
      with loan do
      begin
        int_factor := Rate_Factor;
        if (int_factor = 1.0) then
           pmt_amt := principle / no_of_pmts
        else
          pmt_amt := (principle * periodic_rate) / (1 - int_factor);
        cents := Frac(pmt_amt);
        Payment_Amt := pmt_amt - cents + (Round(cents * 100.0) * 0.01);
      end;
    end; { Payment_Amt }

  procedure Input_Field;
    var parms          : Fld_Parms;
        err_msg,
        cmd_msg        : Str_80;
        last_yr        : Integer;
        len, i         : Byte;
        was_commercial : Boolean;

    function Payment_Cnt: Real;
      begin
        with loan do
          if (Ln((1.0 + periodic_rate)) = 0.0) then
            Payment_Cnt := (principle / payment)
          else
            Payment_Cnt := -(Ln(1.0 - (principle * periodic_rate / payment))
                           / Ln((1.0 + periodic_rate)));
      end; { Payment_Cnt }

    procedure Get_Pmts_Per_Yr;
      type Term_Set    = set of 1..52;

      const  pmt_terms : Term_Set = [1..4,6,12,24,26,52];

      begin
        with loan do
        begin
          pmts_per_yr := (Valid_Int(parms,1,52));
          if (pmts_per_yr in pmt_terms) then
            begin
              periodic_rate := rate / pmts_per_yr / 100.0;
              if (payment > 0.0) and
                 ((periodic_rate * principle) >= payment) then
                begin
                  Disp_Error_Msg(
                  'Payment amount insufficient to pay interest');
                  direction := (-1);
                end;
            end
          else
            begin
              Disp_Error_Msg(
              'Valid entries are 1 2 3 4 6 12 24 26 52');
              direction := ZERO;
            end;
        end;
      end; { Get_Pmts_Per_Yr }

    procedure Get_Select_Yr;

      function End_Yr: Integer;
        var mo_cnt,
            last_yr  : Integer;

        begin
          with loan do
          begin
            if (pmts_per_yr * no_of_pmts) = 0.0 then
              mo_cnt := ZERO
            else
              mo_cnt := Trunc(12 / pmts_per_yr * no_of_pmts + 0.99);
            End_Yr := Trunc((mo_cnt + first_mo - 1) div 12 + first_yr);
          end; {with}
        end; { End_Yr }

      begin { Get_Select_Yr }
        last_yr := End_Yr;
        if (last_yr > ZERO) then
          with loan do
          begin
            select_yr := (Valid_Int(parms,ZERO,last_yr));
            if (select_yr > ZERO) and (select_yr < first_yr) then
              begin
                Disp_Error_Msg('No payments due in year entered.');
                direction := ZERO;
              end;
          end; {with}
      end; { Get_Select_Yr }

    begin { Input_Field }
      default := Current_Value(fld_no);
      Clear_Prompts;
      cmd_msg := PREV_KEY + ' Prev Fld  | ' +
                 CLEAR_KEY + ' Clear Fld  | ' +
                 QUIT_KEY + ' Exit ';
      Display_Prompt(CMD_LINE,'CMD',cmd_msg);
      Display_Prompt(PROMPT_LINE,'MSG',fld_dat[fld_no].fld_msg);
      Display_Prompt(MSG_LINE,ENTER_KEY,default);
      parms := fld_dat[fld_no];
      len := parms.fld_len;
      Init_Field(FILL_CHAR,parms);
      with loan do
      case fld_no of
          1    : begin
                   was_commercial := commercial;
                   inchr := Valid_Chr(parms,['X',SPACE]);
                   commercial := (inchr = 'X');
                   if (not commercial) then
                     begin
                       Init_Field(FILL_CHAR,fld_dat[2]);
                       if was_commercial then
                         FillChar(business_name,Length(business_name),ZERO);
                       direction := 2;
                     end;
                 end;
          2    : begin
                   business_name := (Valid_Str(parms));
                   if (direction = INCR) then
                     begin
                       direction  := 5;
                       for i := 3 to 6 do
                         Init_Field(FILL_CHAR,fld_dat[i]);
                     end;
                 end;
          3    : begin
                   Write('X'); direction := INCR;
                 end;
          4    : begin
                   borrower.last_name := (Valid_Str(parms));
                   if (direction = DECR) then
                     direction := (-3);
                 end;
          5    : borrower.first_name := (Valid_Str(parms));
          6    : borrower.title := (Valid_Str(parms));
          7    : begin
                   collateral := (Valid_Str(parms));
                   if (commercial and (direction = DECR)) then
                     direction := (-5);
                 end;
          8    : principle := (Valid_Real(parms,2,MIN_LOAN,MAX_LOAN));
          9    : rate := (Valid_Real(parms,3,MIN_RATE,MAX_RATE));
          10   : payment := (Valid_Real(parms,2,0.0,MAX_PMT));
          11   : Get_Pmts_Per_Yr;
          12   : first_mo := (Valid_Int(parms,1,12));
          13   : begin
                   first_yr := (Valid_Int(parms,1900,2040));
                   if (payment > 0.0) and (direction = INCR) then
                     begin
                       no_of_pmts := Payment_Cnt;
                       Disp_Field_Value(14);
                       direction := 2;
                     end;
                 end;
          14   : begin
                   no_of_pmts :=
                     (Valid_Real(parms,2,1.0,MAX_TERM));
                   if (direction = INCR) then
                     begin
                       payment := Payment_Amt;
                       Disp_Field_Value(10);
                     end;
                 end;
          15   : Get_Select_Yr;
          16   : out_dev := Valid_Chr(parms,['V','P']);
        end; {case}
        Disp_Field_Value(fld_no);  { Redisplay formated input }
    end; { Input_Field }

  begin { Modify_Data }
    repeat
      Input_field;
      fld_no := fld_no + direction;
      if (fld_no < 1) then
        fld_no := 1;
    until (esc_flag or (fld_no > last_fld));
    if esc_flag then
      begin
        esc_flag := FALSE;
        with loan do
          periodic_rate := rate / pmts_per_yr / 100.0;
        loan.payment := Payment_Amt
      end;
    modified := TRUE;
   end; { Modify_Data }